PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/unitxrf.com/UNITXREF.PAS

Pascal/Delphi Source File | 1991-05-20 | 7.9 KB | 294 lines

Unit UnitXref;
{**************************************************************************}
{*  UnitXref                                                              *}
{*                                                                        *}
{*    Donated to the Public Domain 5/20/91 by Dan Thomas CIS: 72301,2164  *}
{*                                                                        *}
{*  NOTE: YOU MUST SET YOUR STACK SIZE HIGHER TO USE THIS UNIT, AS IN:    *}
{*                                                                        *}
{*              {$M 32768,0,655360}                                      {*}
{*                                                                        *}
{*  The UnitCrossReference function will return a pStringCollection       *}
{*  containing file names for all units referenced by the specified       *}
{*  program source file.                                                  *}
{*                                                                        *}
{*  This routine scans all "Used" units, also.                            *}
{*                                                                        *}
{*  The function GetThePath(FileID) returns the path that the file ID     *}
{*  is in.                                                                *}
{*                                                                        *}
{*  NOTE: The typed constant "UnitSearchPath" is a string that contains   *}
{*        a search path for units.  You may change it if needed.          *}
{*        This unit always checks the path of the source file first,      *}
{*        then it uses the path (when looking for units).                 *}
{**************************************************************************}

INTERFACE

Uses DOS,Objects,PathID,FilExist,ProgErr;

CONST
  UnitSearchPath : string =
      'C:\TP\TVISION;C:\TP\TPU;C:\TP\UNIT;';

TYPE
  pFileBuff=^tFileBuff;
  tFileBuff=array[1..10240] of byte;

VAR
  CurrStartCommentDelim,
  FirstFileID,
  RootDir      : string;


FUNCTION UnitCrossReference(SourceFileID: string): pStringCollection;
FUNCTION GetThePath(FileID: string): string;

IMPLEMENTATION

FUNCTION StripRec(s : string) : string;

var
  x,last_non_space  : byte;
  s1 : string;

begin
  s1 := '';
  last_non_space := 0;
  for x := 1 to length(s) do s[x] := Upcase(s[x]);
  for x := 1 to length(s) do begin
    if CurrStartCommentDelim = '' then
      if (s[x] = '{') and (copy(s,x,4) <> '{$I ') then
        CurrStartCommentDelim := '{'
      else
      if (x < length(s)) and (s[x] = '(') and (s[x+1] = '*') then
        CurrStartCommentDelim := '(*'
      else
      if (s[x] <> ' ') or (s1 <> '') then
        begin
          s1[length(s1)+1] := s[x];
          s1[0] := char(length(s1)+1);
          if s[x] <> ' ' then
            last_non_space := length(s1);
        end
      else
        begin end
    else
    if (s[x] = '}') and (CurrStartCommentDelim = '{') then
      CurrStartCommentDelim := ''
    else
    if (x < length(s)) and (s[x] = '*') and (s[x+1] = ')')
        and (CurrStartCommentDelim = '(*') then
      CurrStartCommentDelim := '';
  end; {of for}
  s1[0] := char(last_non_space);
  StripRec := s1;
end; {StripRec}

FUNCTION GetThePath(FileID: string): string;

var
  p,s,s1 : string;
  x : byte;

begin
  GetThePath := '';
  if file_exists(RootDir+FileID) then
    begin
      GetThePath := RootDir;
      exit;
    end;

  s := StripRec(UnitSearchPath);
  While (s <> '') do begin
    x := pos(',',s);
    if x = 0 then
      x := pos(';',s);
    if x = 0 then
      x := length(s) + 1;
    p := StripRec(copy(s,1,x-1));
    s1 := path_plus_file_id(p,FileID);
    if file_exists(s1) then
      begin
        GetThePath := p;
        exit;
      end;
    if x > length(s) then
      s := ''
    else
      delete(s,1,x);
  end; {of While}
end; {GetThePath}

FUNCTION UnitCrossReference(SourceFileID: string): pStringCollection;

VAR
  UnitColl     : pStringCollection;

PROCEDURE Initialize;

var
  n,e : string;

begin
  FSplit(FExpand(SourceFileID),RootDir,n,e);
  UnitColl := New(pStringCollection,init(500,100));
  CurrStartCommentDelim := '';
  FirstFileID := '';
end; {Initialize}

PROCEDURE ProcessSource(FileID : string);

var
  SourceFile : text;
  SourceRec  : string;
  ProcessingUses : boolean;
  FileBuff       : pFileBuff;

  procedure CheckSourceIOResult;
    var
      e : integer;
    begin
      e := IOResult;
      if e <> 0 then
        program_i_o_error(e,FileID);
    end; {CheckSourceIOResult}

  procedure OpenFile;
    begin
      {$I-}
      Assign(SourceFile,FileID);
      new(FileBuff);
      SetTextBuf(SourceFile,FileBuff^);
      Reset(SourceFile);
      CheckSourceIOResult;
      {$I+}
    end; {OpenFile}

  function PartialMatch(substr, target : string) : boolean;
    begin
      if length(target) < length(substr) then
        PartialMatch := false
      else
        begin
          target[0] := char(length(substr));
          PartialMatch := (substr = target);
        end;
    end; {PartialMatch}

  procedure ProcessUnit(FileName : string);
    var
      s : string;
    begin
      s := GetThePath(FileName);
      if s <> '' then
        begin
          s := path_plus_file_id(s,FileName);
          ProcessSource(s);
        end;
    end; {ProcessUnit}

  procedure ProcessUses(s : string);
    var
      x : byte;
      i : integer;
      UnitName : string;
    begin
      if not ProcessingUses then
        Delete(s,1,5);
      s := StripRec(s);
      While (s <> '') do begin
        x := pos(',',s);
        if x = 0 then
          x := pos(';',s);
        if x = 0 then
          x := length(s) + 1;
        UnitName := StripRec(copy(s,1,x-1)) + '.PAS';
        i := UnitColl^.Count;
        UnitColl^.Insert(NewStr(UnitName));
        if UnitColl^.Count > i then
          ProcessUnit(UnitName);
        if x > length(s) then
          s := ''
        else
          delete(s,1,x);
      end; {of While}
    end; {ProcessUses}

  procedure ProcessIncludes(s : string);
    var
      x : byte;
      i : integer;
      UnitName : string;
    begin
      Delete(s,1,4);
      s := StripRec(s);
      x := 1;
      while (x <= length(s)) and (s[x] <> ' ') and (s[x] <> '}') do inc(x);
      UnitName := copy(s,1,x-1);
      i := UnitColl^.Count;
      UnitColl^.Insert(NewStr(UnitName));
      if UnitColl^.Count > i then
        ProcessUnit(UnitName);
    end; {ProcessIncludes}

  procedure ProcessFile;
    var
      done : boolean;
      s    : string;
    begin
      done := eof(SourceFile);
      ProcessingUses := false;
      if FirstFileID = '' then
        FirstFileID := FIleID;
      While not done do begin
        {$I-} Readln(SourceFile,SourceRec); {$I+}
        CheckSourceIOResult;
        s := StripRec(SourceRec);
        if (ProcessingUses) or (PartialMatch('USES ',s)) then
          begin
            ProcessUses(s);
            ProcessingUses := (Pos(';',s) = 0);
          end
        else
        if PartialMatch('{$I ',s) then
          ProcessIncludes(s)
        else
        if (FIleID <> FirstFileID) and (PartialMatch('IMPLEMENTATION ',s)) then
          done := true;
        if not done then
          done := eof(SourceFile);
      end; {of While}
    end; {ProcessFile}

  procedure CloseFile;
    begin
      {$I-} Close(SourceFile); {$I+}
      CheckSourceIOResult;
      dispose(FileBuff);
    end; {CloseFile}

begin {ProcessSource}
  writeln('ProcessSource: ',FileID);
  OpenFile;
  ProcessFIle;
  CloseFile;
  writeln('Done with ',FileID);
end; {ProcessSource}

PROCEDURE Closing;

begin
  CurrStartCommentDelim := '';
end; {Closing}


BEGIN
  Initialize;
  ProcessSource(SourceFileID);
  Closing;
  UnitCrossReference := UnitColl;
END;

end.